home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / dviware / ln03 / rmcs / cli.for < prev    next >
Text File  |  1989-06-06  |  12KB  |  496 lines

  1.     SUBROUTINE CLI
  2.      
  3. C FUNCTIONAL DESCRIPTION:    
  4. C    Uses Niel Kempson's routines to extract the command line information
  5. C DUMMY ARGUMENTS:
  6. C    none
  7. C IMPLICIT INPUTS:
  8. C    none
  9. C IMPLICIT OUTPUTS:
  10. C    All values in COMMON/GINOTOSIX/ initialized
  11. C SIDE EFFECTS:
  12. C    none
  13.     IMPLICIT NONE
  14.  
  15.     INCLUDE '($SSDEF)'
  16.     INCLUDE '($NAMDEF)'
  17.     
  18.     INTEGER*4    SEGMENT        !Segment number in saved drawing
  19.     REAL*4        WIDTH        !Desired width
  20.     REAL*4        HEIGHT        !Desired height
  21.     REAL*4        SCALE        !Desired scale factor
  22.     CHARACTER*255    INPUT        !Name of input file
  23.     CHARACTER*255    OUTPUT        !Name of output file
  24.     LOGICAL        FORMFEED    !Do we want a formfeed at the end of the
  25.                     !file?
  26.  
  27.     COMMON/GINOTOSIX/INPUT,OUTPUT,WIDTH,HEIGHT,SCALE,SEGMENT,FORMFEED
  28.  
  29.     INTEGER*4    CLI_STATUS
  30.     INTEGER*4    CLI_STRING_LENGTH
  31.     INTEGER*4    FILE_NAME_STATUS_BITS
  32.     INTEGER*4    INPUT_LENGTH
  33.     INTEGER*4    OUTPUT_LENGTH
  34.     INTEGER*4    OUTPUT__LENGTH
  35.     INTEGER*4    PARSE_STATUS
  36.     INTEGER*4    F_DOLLAR_PARSE
  37.     CHARACTER*255    CLI_STRING
  38.     CHARACTER*255    OUTPUT_
  39.     CHARACTER*255    DEFAULT_FILESPEC
  40.     CHARACTER*255    DEFAULT_NAME
  41.     INTEGER*4    DEFAULT_NAME_LENGTH
  42.     INTEGER*4    DEFAULT_TYPE_LENGTH
  43.     INTEGER*4    DEFAULT_FILESPEC_LENGTH
  44.      
  45.     PARAMETER    PARSE_CONCEAL = 0
  46.     PARAMETER    PARSE_NOCONCEAL = 1
  47.     PARAMETER    PARSE_SYNTAX_ONLY = 2
  48.     PARAMETER    PARSE_CHECK_EXISTS = 0
  49.  
  50.     EXTERNAL    CLI$PRESENT
  51.     EXTERNAL    CLI$GET_VALUE
  52.  
  53.     INTEGER*4    CLI$PRESENT
  54.     INTEGER*4    CLI$GET_VALUE
  55.  
  56.     EXTERNAL    CLI$_PRESENT
  57.     EXTERNAL    CLI$_ABSENT
  58.     EXTERNAL    CLI$_NEGATED
  59.     EXTERNAL    CLI$_COMMA
  60.  
  61.     SEGMENT = 0
  62.     CLI_STATUS = CLI$PRESENT ('SEGMENT')
  63.     IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) THEN
  64.         CLI_STATUS = CLI$GET_VALUE ('SEGMENT', 
  65.     1                CLI_STRING, 
  66.     1                CLI_STRING_LENGTH)
  67.         
  68.         IF (CLI_STATUS .EQ. SS$_NORMAL) THEN 
  69.         READ (CLI_STRING(1:CLI_STRING_LENGTH), 110) SEGMENT
  70.         ELSE
  71.         TYPE *,'GINOTOSIX Error - Invalid segment'
  72.         STOP
  73.         END IF
  74.         IF (SEGMENT.LT.0) THEN
  75.         TYPE *,'GINOTOSIX Error - Invalid segment'
  76.         STOP
  77.         END IF
  78.  
  79.     END IF       
  80.  
  81.     SCALE = 0
  82.     CLI_STATUS = CLI$PRESENT ('SCALE')
  83.     IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) THEN
  84.         CLI_STATUS = CLI$GET_VALUE ('SCALE', 
  85.     1                CLI_STRING, 
  86.     1                CLI_STRING_LENGTH)
  87.         
  88.         IF (CLI_STATUS .EQ. SS$_NORMAL) THEN 
  89.         READ (CLI_STRING(1:CLI_STRING_LENGTH), 100, ERR=200) SCALE
  90.         ELSE
  91. 200        TYPE *,'GINOTOSIX Error - Invalid scale'
  92.         STOP
  93.         END IF
  94.  
  95.     END IF       
  96.  
  97.     WIDTH = 0
  98.     HEIGHT = 0
  99.     CLI_STATUS = CLI$PRESENT ('SIZE')
  100.     
  101.     IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) THEN
  102.     
  103.         CLI_STATUS = CLI$GET_VALUE ('SIZE.WIDTH', 
  104.     1                CLI_STRING, 
  105.     1                CLI_STRING_LENGTH)
  106.  
  107.         IF (CLI_STATUS .EQ. SS$_NORMAL) THEN
  108.         READ (CLI_STRING(1:CLI_STRING_LENGTH), 100) WIDTH
  109.         ELSE
  110.         TYPE *,'GINOTOSIX Error - Invalid width'
  111.         STOP
  112.         END IF
  113.     
  114.         CLI_STATUS = CLI$GET_VALUE ('SIZE.HEIGHT', 
  115.     1                CLI_STRING, 
  116.     1                CLI_STRING_LENGTH)
  117.  
  118.         IF (CLI_STATUS .EQ. SS$_NORMAL) THEN 
  119.         READ (CLI_STRING(1:CLI_STRING_LENGTH), 100) HEIGHT
  120.         ELSE
  121.         TYPE *,'GINOTOSIX Error - Invalid height'
  122.         STOP
  123.         END IF
  124.  
  125.     END IF       
  126.  
  127.     CLI_STATUS = CLI$PRESENT ('OUTPUT')
  128.     IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) THEN
  129.         CLI_STATUS = CLI$GET_VALUE (
  130.     1        'OUTPUT', 
  131.     1        OUTPUT_, 
  132.     1        OUTPUT__LENGTH)
  133.  
  134.         PARSE_STATUS = F_DOLLAR_PARSE(
  135.     1        OUTPUT_(1:OUTPUT__LENGTH),
  136.     1        '*.*;*',
  137.     1        'FULL',
  138.     1        PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  139.     1        OUTPUT,
  140.     1        OUTPUT_LENGTH,
  141.     1        FILE_NAME_STATUS_BITS)
  142.  
  143.         IF (IAND(FILE_NAME_STATUS_BITS, NAM$M_WILD_DIR) .NE. 0) THEN
  144.         TYPE *,'GINOTOSIX Error - Illegal output filespec'
  145.         STOP
  146.         END IF
  147.  
  148.     ELSE
  149.  
  150.         OUTPUT(1:7) = '[]*.*;*'
  151.         OUTPUT(8:) = ' '
  152.         OUTPUT_LENGTH = 7
  153.  
  154.     END IF
  155.  
  156.     CALL REMOVE_WILDCARDS (OUTPUT, OUTPUT_LENGTH)
  157.  
  158.     CLI_STATUS = CLI$GET_VALUE('INPUT_FILESPEC',
  159.     1               INPUT,
  160.     1               INPUT_LENGTH)
  161.  
  162.     IF (CLI_STATUS .NE. SS$_NORMAL) THEN
  163.         TYPE *,'GINOTOSIX Error - Illegal input filespec'
  164.         STOP
  165.     END IF
  166.  
  167.     PARSE_STATUS = F_DOLLAR_PARSE (
  168.     1            INPUT(1:INPUT_LENGTH),
  169.     1                '.PIC',
  170.     1                'FULL',
  171.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  172.     1            INPUT,
  173.     1            INPUT_LENGTH,
  174.     1            FILE_NAME_STATUS_BITS)
  175.  
  176.     PARSE_STATUS = F_DOLLAR_PARSE (INPUT,
  177.     1            ' ',
  178.     1            'NAME', 
  179.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  180.     1            DEFAULT_NAME,
  181.     1            DEFAULT_NAME_LENGTH,
  182.     1            FILE_NAME_STATUS_BITS)
  183.  
  184.     DEFAULT_FILESPEC = DEFAULT_NAME(1:DEFAULT_NAME_LENGTH) // '.SIX'
  185.     DEFAULT_FILESPEC_LENGTH = DEFAULT_NAME_LENGTH + 4
  186.  
  187.     PARSE_STATUS = F_DOLLAR_PARSE (
  188.     1            OUTPUT(1:OUTPUT_LENGTH),
  189.     1                DEFAULT_FILESPEC(1:DEFAULT_FILESPEC_LENGTH),
  190.     1                'FULL',
  191.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  192.     1            OUTPUT,
  193.     1            OUTPUT_LENGTH,
  194.     1            FILE_NAME_STATUS_BITS)
  195.  
  196.     IF (IAND (FILE_NAME_STATUS_BITS, NAM$M_WILDCARD) .NE. 0) THEN
  197.         CALL REMOVE_WILDCARDS (OUTPUT, OUTPUT_LENGTH)
  198.     END IF
  199.  
  200.     FORMFEED=.FALSE.
  201.     CLI_STATUS = CLI$PRESENT ('FORMFEED')
  202.     IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) FORMFEED=.TRUE.
  203.  
  204.     RETURN
  205.     
  206. 100    FORMAT (F5.0)
  207. 110    FORMAT (I5)
  208.     
  209.     END
  210.      
  211.     SUBROUTINE REMOVE_WILDCARDS (FILE_SPEC, FILE_SPEC_LENGTH)
  212.     INCLUDE '($NAMDEF)'
  213.     PARAMETER    PARSE_CONCEAL = 0,
  214.     1        PARSE_NOCONCEAL = 1,
  215.     1        PARSE_SYNTAX_ONLY = 2,
  216.     1        PARSE_CHECK_EXISTS = 0
  217.     CHARACTER*(*)    file_spec
  218.     INTEGER*4    file_spec_length
  219.     CHARACTER*255
  220.     1        new_file_spec,
  221.     1        node,
  222.     1        device,
  223.     1        directory
  224.     CHARACTER*255
  225.     1        default_name,
  226.     1        default_type,
  227.     1        name,
  228.     1        type,
  229.     1        version
  230.     INTEGER*4    new_file_spec_length,
  231.     1        node_length,
  232.     1        device_length,
  233.     1        directory_length,
  234.     1        name_length, 
  235.     1        type_length,
  236.     1        version_length,
  237.     1        f_dollar_parse,
  238.     1        parse_status,
  239.     1        file_name_status_bits,
  240.     1        string_length
  241.  
  242.     
  243.     file_spec_length = string_length (file_spec)
  244.  
  245.     parse_status = f_dollar_parse (
  246.     1            file_spec(1:file_spec_length),
  247.     1                ' ',
  248.     1                'NODE',
  249.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  250.     1            node,
  251.     1            node_length,
  252.     1            file_name_status_bits)
  253.     IF (node_length .GT. 0) THEN
  254.         new_file_spec(1:) = node(1:node_length)
  255.     END IF
  256.     new_file_spec_length = node_length
  257.  
  258.     parse_status = f_dollar_parse (
  259.     1            file_spec(1:file_spec_length),
  260.     1                ' ',
  261.     1                'DEVICE',
  262.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  263.     1            device,
  264.     1            device_length,
  265.     1            file_name_status_bits    )
  266.     IF (device_length .GT. 0) THEN
  267.         new_file_spec(new_file_spec_length+1:) = device(1:device_length)
  268.     END IF
  269.     new_file_spec_length = new_file_spec_length + device_length
  270.  
  271.     parse_status = f_dollar_parse (
  272.     1            file_spec(1:file_spec_length),
  273.     1                ' ',
  274.     1                'DIRECTORY',
  275.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  276.     1            directory,
  277.     1            directory_length,
  278.     1            file_name_status_bits)
  279.  
  280.     IF (IAND (file_name_status_bits, NAM$M_WILD_DIR) .EQ. 0) THEN
  281.         IF (directory_length .GT. 0) THEN
  282.         new_file_spec(new_file_spec_length+1:) = 
  283.     1                    directory(1:directory_length)
  284.         END IF
  285.         new_file_spec_length = new_file_spec_length + directory_length
  286.     END IF
  287.  
  288.     parse_status = f_dollar_parse (
  289.     1            file_spec(1:file_spec_length),
  290.     1                ' ',
  291.     1                'NAME',
  292.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  293.     1            name,
  294.     1            name_length,
  295.     1            file_name_status_bits    )
  296.  
  297.     IF (IAND (file_name_status_bits, NAM$M_WILD_NAME) .EQ. 0) THEN
  298.         IF (name_length .GT. 0) THEN
  299.         new_file_spec(new_file_spec_length+1:) = name(1:name_length)
  300.         END IF
  301.         new_file_spec_length = new_file_spec_length + name_length
  302.     END IF
  303.  
  304.     parse_status = f_dollar_parse (
  305.     1            file_spec(1:file_spec_length),
  306.     1                ' ',
  307.     1                'TYPE',
  308.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  309.     1            type,
  310.     1            type_length,
  311.     1            file_name_status_bits    )
  312.  
  313.     IF (IAND (file_name_status_bits, NAM$M_WILD_TYPE) .EQ. 0) THEN
  314.         IF (type_length .GT. 0) THEN
  315.         new_file_spec(new_file_spec_length+1:) = type(1:type_length)
  316.         END IF
  317.         new_file_spec_length = new_file_spec_length + type_length
  318.     END IF
  319.  
  320.     parse_status = f_dollar_parse (
  321.     1            file_spec(1:file_spec_length),
  322.     1                ' ',
  323.     1                'VERSION',
  324.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  325.     1            version,
  326.     1            version_length,
  327.     1            file_name_status_bits)
  328.  
  329.     IF (IAND (file_name_status_bits, NAM$M_WILD_VER) .EQ. 0) THEN
  330.         IF (version_length .GT. 0) THEN
  331.         new_file_spec(new_file_spec_length+1:) = 
  332.     1                    version(1:version_length)
  333.         END IF
  334.         new_file_spec_length = new_file_spec_length + version_length
  335.     END IF
  336.  
  337.     IF (new_file_spec_length .GT. 0) THEN
  338.         file_spec(1:) = new_file_spec(1:new_file_spec_length)
  339.     END IF
  340.     file_spec_length = new_file_spec_length
  341.  
  342.     RETURN
  343.     END
  344.  
  345.     INTEGER*4 FUNCTION f_dollar_parse (file_spec, 
  346.     1                default_file_spec,
  347.     1                parse_type,
  348.     1                parse_flags,
  349.     1                return_buffer, 
  350.     1                return_string_length,
  351.     1                file_name_status_bits)
  352.     INCLUDE '($FABDEF)'
  353.     INCLUDE '($NAMDEF)'
  354.     PARAMETER    PARSE_CONCEAL = 0,
  355.     1        PARSE_NOCONCEAL = 1,
  356.     1        PARSE_SYNTAX_ONLY = 2,
  357.     1        PARSE_CHECK_EXISTS = 0
  358.     CHARACTER*(*)    file_spec,
  359.     1        default_file_spec,
  360.     1        return_buffer,
  361.     1        parse_type
  362.     INTEGER*4    return_string_length,
  363.     1        parse_flags,
  364.     1        file_name_status_bits
  365.     RECORD /FABDEF/ fab
  366.     RECORD /NAMDEF/ nam
  367.     CHARACTER*16    local_parse_type
  368.     CHARACTER*255
  369.     1        full_filespec    
  370.     INTEGER*4    SYS$PARSE,
  371.     1        start_char, 
  372.     1        stop_char, 
  373.     1        return_buffer_size,
  374.     1        parsed_string_length
  375.     BYTE        int_to_byte
  376.  
  377.     fab.FAB$B_BID = FAB$C_BID
  378.     fab.FAB$B_BLN = FAB$C_BLN
  379.  
  380.     fab.FAB$L_FNA = %LOC (file_spec)
  381.     fab.FAB$B_FNS = int_to_byte (LEN (file_spec))
  382.  
  383.     fab.FAB$L_DNA = %LOC (default_file_spec)
  384.     fab.FAB$B_DNS = int_to_byte (LEN (default_file_spec))
  385.  
  386.     fab.FAB$L_NAM = %LOC (nam)
  387.  
  388.     nam.NAM$B_BID = NAM$C_BID
  389.     nam.NAM$B_BLN = NAM$C_BLN
  390.  
  391.     nam.NAM$L_ESA = %LOC (full_filespec)
  392.     nam.NAM$B_ESS = int_to_byte (MIN (LEN (full_filespec), 255))
  393.  
  394.     nam.NAM$B_NOP = 0
  395.  
  396.     IF (IAND (parse_flags, PARSE_NOCONCEAL) .NE. 0) THEN
  397.         nam.NAM$B_NOP = NAM$M_NOCONCEAL
  398.     END IF 
  399.  
  400.     IF (IAND (parse_flags, PARSE_SYNTAX_ONLY) .NE. 0) THEN
  401.         nam.NAM$B_NOP = nam.NAM$B_NOP + NAM$M_SYNCHK
  402.     END IF
  403.  
  404.     f_dollar_parse = SYS$PARSE (fab)
  405.     file_name_status_bits = nam.NAM$L_FNB    
  406.  
  407.     CALL STR$UPCASE (local_parse_type, parse_type)
  408.  
  409.     IF (local_parse_type .EQ. 'NODE') THEN
  410.         start_char = nam.NAM$L_NODE - nam.NAM$L_ESA + 1
  411.         stop_char = start_char + ZEXT (nam.NAM$B_NODE) - 1
  412.  
  413.     ELSE IF (local_parse_type .EQ. 'DEVICE') THEN
  414.         start_char = nam.NAM$L_DEV - nam.NAM$L_ESA + 1
  415.         stop_char = start_char + ZEXT (nam.NAM$B_DEV) - 1
  416.  
  417.     ELSE IF (local_parse_type .EQ. 'DIRECTORY') THEN
  418.         start_char = nam.NAM$L_DIR - nam.NAM$L_ESA + 1
  419.         stop_char = start_char + ZEXT (nam.NAM$B_DIR) - 1
  420.  
  421.     ELSE IF (local_parse_type .EQ. 'NAME') THEN
  422.         start_char = nam.NAM$L_NAME - nam.NAM$L_ESA + 1
  423.         stop_char = start_char + ZEXT (nam.NAM$B_NAME) - 1
  424.  
  425.     ELSE IF (local_parse_type .EQ. 'TYPE') THEN
  426.         start_char = nam.NAM$L_TYPE - nam.NAM$L_ESA + 1
  427.         stop_char = start_char + ZEXT (nam.NAM$B_TYPE) - 1
  428.  
  429.     ELSE IF (local_parse_type .EQ. 'VERSION') THEN
  430.         start_char = nam.NAM$L_VER - nam.NAM$L_ESA + 1
  431.         stop_char = start_char + ZEXT (nam.NAM$B_VER) - 1
  432.  
  433.     ELSE IF (local_parse_type .EQ. 'FULL') THEN
  434.         start_char = 1
  435.         stop_char = ZEXT (nam.NAM$B_ESL)
  436.  
  437.     ELSE
  438.         TYPE *, 'Invalid parse string: (',local_parse_type,').'
  439.         CALL LIB$SIGNAL (MODIFY$INVPARTYP, 1, local_parse_type)
  440.         CALL EXIT
  441.     END IF        
  442.     
  443.     parsed_string_length = stop_char - start_char + 1
  444.     return_buffer_size = LEN (return_buffer)
  445.     return_string_length = MIN (return_buffer_size, parsed_string_length)
  446.  
  447.     IF (return_string_length .GT. 0) THEN
  448.         return_buffer(1:) = full_filespec(
  449.     1    start_char:start_char + return_string_length - 1)
  450.     END IF
  451.  
  452.     RETURN
  453.     END
  454.  
  455.     INTEGER*4 FUNCTION string_length (string)
  456.     IMPLICIT NONE
  457.     CHARACTER*(*)    string
  458.     CHARACTER    this_char
  459.     string_length = LEN (string)
  460.  
  461.     DO WHILE (string_length .GT. 0)
  462.         this_char = string(string_length:string_length)
  463.         IF ((this_char .NE. ' ') .AND. (this_char .NE. CHAR(9))) THEN
  464.         RETURN
  465.         END IF
  466.         string_length = string_length - 1
  467.     END DO
  468.     RETURN
  469.     END
  470.  
  471.     BYTE FUNCTION int_to_byte (number)
  472.     IMPLICIT NONE
  473.     INTEGER*4 number
  474.  
  475.     IF ( IAND (number, '00000080'X) .NE. 0) THEN
  476.         int_to_byte = IOR (number, 'FFFFFF00'X)
  477.     ELSE
  478.         int_to_byte = IAND (number, '000000FF'X)
  479.     END IF
  480.     
  481.     RETURN
  482.     END
  483.